home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / surface.pqs / SURFACE.PAS
Encoding:
Pascal/Delphi Source File  |  1985-06-03  |  4.1 KB  |  131 lines
  1. Program Surface (Output);
  2.  
  3. {****************************************************************************}
  4. {                                                                            }
  5. { Program: Surface.Pas                                                       }
  6. { Programmer: Keith Shafer                                                   }
  7. {             San Diego, CA 92120                                            }
  8. {                                                                            }
  9. { This program is a pascal adaptation of the public domain program titled    }
  10. { Surface.bas.  It shows the graphic ability of the IBM PC or compatible     }
  11. { when used with turbo pascal.                                               }
  12. {                                                                            }
  13. {****************************************************************************}
  14.  
  15. Const Rho   = 100;
  16.       D     = 2000;
  17.       Theta = 0.1;
  18.       Phi   = 1.3;
  19. Var
  20.    W, X, Y, Z, S1, S2, C1, C2 : Real;
  21.    XE, YE, ZE, SX, SY, OldX, OldY, DX, SL : Real;
  22.    I, J, FL, F, XP, YP : Integer;
  23.    YMin : Array[0..639] of Integer;
  24.    YMax : Array[0..639] of Integer;
  25.  
  26.  
  27. Function Find_Z : Real;
  28.  
  29. Begin
  30.     Find_Z:=14 * EXP (-0.04 * W) * COS (0.15 * W);
  31. End;
  32.  
  33.  
  34. Procedure Initialize;
  35.  
  36. Var I : Integer;
  37.  
  38. Begin
  39.     S1:=Sin(Theta);
  40.     S2:=Sin(Phi);
  41.     C1:=Cos(Theta);
  42.     C2:=Cos(Phi);
  43.     For I:=0 to 639
  44.         do YMin[I]:=199;
  45.     W:=0; X:=0; Y:=0; Z:=0;
  46.     XE:=0; YE:=0; ZE:=0; SX:=0; SY:=0; OldX:=0; OldY:=0;
  47.     FL:=0; F:=0; DX:=0; SL:=0; YP:=0; XP:=0;
  48. End;
  49.  
  50. Procedure Get_Values_N_Plot;
  51.  
  52. Label Skip, return;
  53.  
  54. Begin
  55.     XE:=-X * S1 + Y * C1;
  56.     YE:=-X * C1 * C2 - Y * S1 * C2 + Z * S2;
  57.     ZE:=-X * S2 * C1 - Y * S1 * S2 - Z * C2 + Rho;
  58.     SX:=D * XE / ZE + 320;
  59.     SY:=-5 * D * YE / ZE / 12 + 120;
  60.     If (SX < 0) or (SX > 639) then goto return;
  61.     If FL = 0 then
  62.        begin
  63.            FL:=1;
  64.            F:=0;
  65.        end
  66.    else
  67.    begin
  68.        DX:=OLDX - SX;
  69.        If DX = 0 then DX:=1;
  70.        SL:=(OLDY - SY) / DX;
  71.        YP:=Round(OLDY);
  72.        For XP:= Round(OLDX)+1 to Round(SX)
  73.            do begin
  74.                   YP:=YP + Round(SL);
  75.                   If YP <= YMin[XP] then
  76.                      begin
  77.                          YMin[XP]:=YP;
  78.                          If F = 0 then
  79.                             begin
  80.                                 Plot(XP,YP,1);
  81.                                 F:=1;
  82.                             end;
  83.                          Draw(XP,YP,Round(OldX),Round(OldY),1);
  84.                          If YP < YMax[XP] then goto Skip
  85.                          else
  86.                             begin
  87.                                 YMax[XP]:=YP;
  88.                                 If F = 0 then
  89.                                    begin
  90.                                        Plot(XP,YP,1);
  91.                                        F:=1;
  92.                                    end;
  93.                                 Draw(XP,YP,Round(OldX),Round(OldY),1);
  94.                             end;
  95.                          goto Skip;
  96.                      end; { yp <= ymin[xp] }
  97.                      If YP >= YMax[XP] then
  98.                         begin
  99.                             YMax[XP]:=YP;
  100.                             If F = 0 then
  101.                                begin
  102.                                    Plot(XP,YP,1);
  103.                                    F:=1;
  104.                                end;
  105.                             Draw(XP,YP,Round(OldX),Round(OldY),1);
  106.                             goto Skip;
  107.                         end;
  108.                         F:=0;
  109. Skip:         end;
  110.    end;
  111. return:       OldX:=SX;
  112.               OldY:=SY;
  113. End;
  114.  
  115. Begin { main }
  116.     Initialize;
  117.     HiRes;
  118.     HiResColor(15);
  119.     For I:=24 downto -24
  120.         do begin
  121.                X:=I * 0.5;
  122.                FL:=0;
  123.                For J:=-60 to 60
  124.                    do begin
  125.                           Y:=J * 0.2;
  126.                           W:=X * X + Y * Y;
  127.                           Z:=Find_Z;
  128.                           Get_Values_N_Plot;
  129.                       end;
  130.            end;
  131. End.